home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
tpcase.zip
/
TPCASE.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1993-01-04
|
15KB
|
394 lines
PROGRAM Cases;
{$D-,R-,V-}
uses DOS, Crt, Panes;
TYPE
ChFile = Text;
CONST
UCaseChr : Set of Char = ['A'..'Z'];
VAR
InFile, OutFile : ChFile; { Text files }
InFileName, OutFileName : String[65];
Switch : String[1]; { Holds the "u" or "l" params.}
ch : String[255]; { Temporary string to process.}
TbufOut, { Used for dynamic allocation }
TbufIn : Pointer; { of text file buffer. }
NChars : LongInt; { Number of chars processed. }
LL, { Number of lines processed. }
TBufSize : Word; { Max size of file buffer. }
TermFlag : Boolean; { Flag for end of a sentence. }
I, Row,
Col : Byte;
PROCEDURE SetBuf;
Begin
IF MaxAvail > ( 65535 * 2) THEN { TP5.5 limits max size of a }
Begin TBufSize := 65000; End { heap variable to 65519 bytes}
ELSE Begin
TBufSize := MaxAvail div 3; { Leave a margin }
End;
GetMem(TBufIn,TBufSize);
GetMem(TBufOut,TBufSize);
End;
PROCEDURE RestoreCursor ( Row, Col : Integer);
VAR TheRegs : Registers;
BEGIN
TheRegs.AH := $2; { function request code}
TheRegs.DH := Row; { new row position }
TheRegs.DL := Col; { new column position }
TheRegs.BH := 0; { page 0 }
Intr ( $10, TheRegs); { BIOS interrupt }
END; { RestoreCursor }
FUNCTION IntToStr(i: Longint): string;
var
s: string[11]; { length of a LONGINT variable }
begin
Str(i, s);
IntToStr := s;
end;
PROCEDURE CenterString(TheString: String; Line: Byte);
VAR
Offset : Byte; { this routine is window oriented }
Begin
Offset := ((Lo(WindMax) - Lo(WindMin))Div 2 +1 ) - (Length(TheString)DIV 2);
GotoXY(Offset,line);
Write(TheString);
End;
PROCEDURE Chirp;
Begin
Sound(900); Delay(25);
Sound(750); Delay(25);
NoSound;
End;
PROCEDURE Buzz;
Begin
Sound(100); Delay(250);
NoSound;
End;
PROCEDURE WaitForUser(PromptStr: String);
Var Ch : Char;
Begin
CenterString(PromptStr, WhereY);
Ch := ReadKey;
Repeat
IF Ch <> #13 THEN
Begin
Buzz;
Ch := ReadKey;
End;
Until Ch = #13;
End;
PROCEDURE CloseUp;
Begin
winclose;
FreeMem(TBufIn,TBufSize); { deallocate the text buffer }
FreeMem(TBufOut,TBufSize);
ShowCursor;
RestoreCursor(Row,Col);
WriteLn(' THANK YOU for using CASE...');
WriteLn(' A public domain program by Peter Gallagher');
WriteLn;
End;
PROCEDURE Instructions;
BEGIN
Buzz;
WinOpen(8,4,63,23,HWinAttr);Winborder(1,HBordAttr,' CASE Help ');
WriteLn('The command to start CASE must specify which process ');
WriteLn(' you wish to use: either <u>pper or <l>ower case. ');
WriteLn(' Use only one of these commands each time you use ');
WriteLn(' CASE. There must be a space before and after the ');
WriteLn(' switch. You must also name the file to process ');
WriteLn(' and you may specify a name for the converted file.');
WriteLn(' If you do not name a file for output CASE will ');
WriteLn(' create a new file using the name of the input file');
WriteLn(' but adding the extension "LOW" or "UP ". ');
WriteLn;
WriteLn('You may specify input and output files in any disk ');
WriteLn(' directory by including the full path name. ');
WriteLn(' Like this... ');
WriteLn(' [Disk Drive name]:\[directory]\..Filename.Ext ');
WriteLn(' eg: Case u C:\Word\Docs\Uppercase.DOC ');
WriteLn(' drive---^ ^----^--path ^----File.Extension ');
WriteLn;
WaitForUser('* Press ENTER when you are ready to restart *');
WinClose;
WinClose;
RestoreCursor(Row,Col);
WriteLn('Command Line format is: ');
WriteLn('Case <u> <l> [d:\path\]InputFile.ext [OutputFile.ext]');
WriteLn;
ShowCursor; Halt;
END;
PROCEDURE Lower(Var STRG : String); {using code created from Lower.asm}
BEGIN
Inline(
$C4/$BE/STRG/ { LES DI,[BP] ; TP SETUP}
$26/$8A/$0D/ { MOV CL,ES [DI] ;}
$FE/$C1/ { INC CL ;}
$FE/$C9/ {L1: DEC CL ; Get a chr}
$74/$5E/ { JZ L3 ; All gone, exit.}
$47/ { INC DI ;}
$26/$80/$3D/$2E/ {L2: ES: CMP BYTE PTR [DI],'.' ; Is this a sentence}
$74/$1E/ { JZ T1 ; terminator?}
$26/$80/$3D/$3F/ { ES: CMP BYTE PTR [DI],'?' ; Go to Term routine}
$74/$18/ { JZ T1 ; at T1.}
$26/$80/$3D/$21/ { ES: CMP BYTE PTR [DI],'!' ;}
$74/$12/ { JZ T1 ;}
$26/$80/$3D/$41/ { ES: CMP BYTE PTR [DI],'A' ; Or is it in the}
$72/$E3/ { JB L1 ; range A..Z ?}
$26/$80/$3D/$5A/ { ES: CMP BYTE PTR [DI],'Z' ;}
$77/$DD/ { JA L1 ;}
$26/$80/$05/$20/ { ES: ADD BYTE PTR [DI],32 ; Then add 32}
$EB/$D7/ { JMP L1 ; and loop for next.}
$FE/$C9/ {T1: DEC CL ; Sentence Terminator}
$74/$35/ { JZ L3 ; detected, get next}
$47/ { INC DI ; chr.}
$26/$80/$3D/$20/ { ES: CMP BYTE PTR [DI],$20 ; If a SP check}
$74/$0E/ { JE X1 ; the next char.}
$26/$80/$3D/$21/ { ES: CMP BYTE PTR [DI],'!' ; If a '!' or a '.'}
$74/$EF/ { JE T1 ; restart the term}
$26/$80/$3D/$2E/ { ES: CMP BYTE PTR [DI],'.' ; routine ie pass}
$74/$E9/ { JZ T1 ; this one thru.}
$EB/$C3/ { JMP L2 ; Nope. So test it.}
$FE/$C9/ {X1: DEC CL ; A term and one SP}
$74/$1C/ { JZ L3 ; found, get}
$47/ { INC DI ; next chr.}
$26/$80/$3D/$20/ { ES: CMP BYTE PTR [DI],$20 ; Is it a SP?}
$74/$02/ { JZ X2 ;}
$EB/$B6/ { JMP L2 ; No? False alarm.}
$FE/$C9/ {X2: DEC CL ; If here then we need}
$74/$0F/ { JZ L3 ; to find the next Ucase}
$47/ { INC DI ; chr and pass it thru}
$26/$80/$3D/$41/ { ES: CMP BYTE PTR [DI],'A' ; without conversion}
$72/$F5/ { JB X2 ; Below A, try again}
$26/$80/$3D/$5A/ { ES: CMP BYTE PTR [DI],'Z' ;}
$77/$EF/ { JA X2 ; Above Z, try again}
$EB/$9E); { JMP L1 ; Found it, go back to top.}
{L3: ; Exit}
End; { lower }
PROCEDURE Upper(Var Strg : String); { Using code in Upper.asm }
Begin
Inline(
$C4/$BE/STRG/ { LES DI,[BP] ; TP SETUP}
$26/$8A/$0D/ { MOV CL,ES [DI] ;}
$FE/$C1/ { INC CL ;}
$FE/$C9/ {L1: DEC CL ; Get a chr.}
$74/$13/ { JZ L2 ; All gone, exit.}
$47/ { INC DI ;}
$26/$80/$3D/$61/ { ES: CMP BYTE PTR [DI],'a' ; Is it in range}
$72/$F5/ { JB L1 ; a..z ?}
$26/$80/$3D/$7A/ { ES: CMP BYTE PTR [DI],'z' ; Loop if not.}
$77/$EF/ { JA L1 ; Else..}
$26/$80/$2D/$20/ { ES: SUB BYTE PTR [DI],32 ; subtract 32}
$EB/$E9); { JMP L1 ; and loop for next.}
{L2: ; Exit}
End; { upper }
PROCEDURE ShowProgress(Val,Small,Large: Longint); { Do something on screen }
CONST MarkerCh = #254;
Begin
IF (Val MOD Small = (Small - 1)) THEN
Write(MarkerCh);
IF (Val MOD Large = (Large - 1)) THEN
Begin
Write (' ',LL,' lines processed');
WriteLn; End
End;
PROCEDURE ReportError(ErrorRef : String; ErrorCode: Integer);
{ Each of these are treated as fatal and the program is halted }
{ after attempting to give the user a hint about what to do. }
Begin
WinOpen(10,14,70,18,HWinAttr);Winborder(1,HBordAttr,' OOPS! ');
Buzz;
Case ErrorCode of
2 : writeln(' ',ErrorRef,' not found. Have you entered the name right ?');
3 : writeln(' Path ',ErrorRef,' not found (check the directory)');
4 : writeln(' Too many files open. You may need to fix the Config.sys.');
5 : writeln(' Can`t open ',ErrorRef,'. Check the file name.');
101 : writeln(' Can`t write to the disk ... it`s full.');
103,104 : writeln(' Can`t find a file with the name (or path) ',ErrorRef);
150 : writeln(' The disk you named is Write-Protected (check the tab)');
152 : writeln(' The drive isn`t ready. Have you loaded a disk ?');
998 : writeln(' ',ErrorRef,' can`t be used for BOTH input and output.');
999 : writeln(' "',ErrorRef,'" isn`t a legal switch. Use "u" or "l" only.');
Else writeln(' Something screwy here ! Too many commands? Try again.');
end; {case}
WaitForUser('* Press ENTER when ready *');
WinClose;
WinClose;
RestoreCursor(Row,Col);
WriteLn('Please try again. The command format is: ');
WriteLn('CASE <u> <l> [Drive:\path\]InputFile.ext [d:\path\][OutputFile.ext]');
ShowCursor; Halt;
End;
PROCEDURE MakeNames; { Set up names for }
VAR I : Integer; { InFile and Outfile depending}
Ext, Sw : String; { on the first parameter. }
Begin
InFileName := ParamStr(2);
Sw := Copy(ParamStr(1),1,1); { Allow for entry of full }
Case Sw[1] of { word eg. "upper" but take }
'l','L': Ext := 'LOW'; { only first character in }
'u','U': Ext := 'UP '; { upper or lower case. }
Else ReportError(ParamStr(1), 999);
End;
I := pos('.',InFileName);
IF I = 0 THEN Begin
OutFileName := InFileName + '.' + Ext; End
ELSE Begin
OutFileName := copy(InFileName,1,I)+Ext; End;
End;
FUNCTION CreateFile (Var TheFile : ChFile; FName : STRING): Boolean;
{Create a new File. If not ok closes the file.}
VAR
Result : Integer;
Begin
Assign( TheFile, FName);
SetTextBuf( TheFile, TBufOut^, TBufSize);
{$I-} Rewrite ( TheFile ); {$I+}
Result := IOResult;
IF Result <> 0 THEN ReportError(FName, Result);
CreateFile := IOResult = 0;
End;
FUNCTION OpenFile ( VAR TheFile : ChFile; FName : STRING): Boolean;
{ opens an existing file }
VAR
Result : Integer;
Begin
Assign( TheFile, FName);
SetTextBuf(TheFile, TBufIn^, TBufSize);
{$I-} Reset ( TheFile ); {$I+}
Result := IOResult;
IF Result <> 0 THEN ReportError(FName, Result);
OpenFile := IOResult = 0;
End;
PROCEDURE GetParams;
VAR
P : Integer;
BEGIN
P := ParamCount;
Begin
Case P of
0,1: Instructions; { No parameters so give help }
2: MakeNames;
3: Begin InFileName := ParamStr(2); OutFileName := ParamStr(3);
IF InFileName = OutFIleName THEN
ReportError(OutFileName,998); End;
ELSE
ReportError('',000); { ?? Garbage on command line. }
End; {select case}
End; {if}
IF NOT OpenFile(InFile, InFileName) THEN CloseUp; { unknown error. }
IF NOT CreateFile(OutFile, OutFileName) THEN CloseUp;
END;
PROCEDURE UCase; { Simple routine. }
Begin
Ch := '';
While NOT EOF(InFile) Do
Begin
ReadLn(InFile,ch);
Inc(LL);
Upper(Ch);
WriteLn(OutFile,ch);
Inc(NChars,Length(ch));
ShowProgress(LL,4,90);
End; { while }
Write(' ',LL,' lines processed');
End;
PROCEDURE LCase; { A more complex routine. }
Var { Using ReadLn to get text }
FirstCh : String[1]; { means we need some means of}
Temp : String[3]; { flagging when one line ends}
Begin { in a terminator so that we }
FirstCh := ''; Temp := ''; { can keep the first ucase }
TermFlag := True; Ch := ''; { char in the next line. }
While NOT EOF(InFile) DO
Begin
ReadLn(InFile,ch);
Inc(LL);
IF TermFlag AND (Length(Ch) > 1) THEN
Begin { Last line ended in a sentence }
I := 1; { terminator: "." or "!" or "?" }
FirstCh := Copy(ch,I,1); { So find the first ucase char. }
While NOT (FirstCh[1] in UCaseChr) AND (I < Length(Ch)) DO Begin
INC(I);
FirstCh := Copy(ch, I ,1);
End; {While}
IF I = Length(Ch) THEN { Got to end of line without }
Begin { finding an ucase character. }
I := 0; FirstCh := ''; { Wipe the index and FirstCh }
End { vars but leave TermFlag set. }
ELSE Begin TermFlag := False; End;{ Here because found an UCase }
End; { reset TermFlag but keep FirstCh }
{ and I for later. }
Lower(ch); { Lowercase the whole line. }
Temp := Copy(ch,(Length(ch)-2),3); { If thelast three chars contain}
IF (Pos('.', Temp) + Pos('!',Temp) + Pos('?',Temp)) <> 0 THEN
TermFlag := True; { a terminator, set the Flag. }
IF FirstCh <> '' THEN Begin { Have we got an unconverted }
Delete(Ch,I,1); { ucase char to reinsert? }
Insert(FirstCh,Ch,I); { Replace the converted char }
FirstCh := ''; End; { at index and wipe the var. }
WriteLn(OutFile,ch); { Write the converted string to }
Inc(NChars,Length(ch)); { the output file and do }
ShowProgress(LL,4,90); { something on the screen. }
End;
Write(' ',LL,' lines processed'); { End of the File, update accounts.}
End;
PROCEDURE Initialise;
Begin
NChars := 0; LL := 0;
Row := WhereY; Col := WhereX;
Switch := '';
SetBuf; HideCursor;
WinOpen(12,6,68,21,MainWinAttr);Winborder(2,BordAttr,' CASE ');
End;
BEGIN { Main }
Initialise;
GetParams;
Window(13,18,67,20);
CenterString('Reading characters from: ', 1);
WriteLn;
CenterString(InFileName,2);
Window(13,7,67,16);
Switch := Copy(ParamStr(1),1,1);
Case Switch[1] of
'l','L': LCase;
'u','U': Ucase;
End;
Close(InFile); Close(OutFile);
Window(13,18,67,20);
Clrscr;
CenterString(IntToStr(Nchars) + ' characters written to',1);
CenterString(OutFileName,2);
WriteLn;
Chirp;
WaitForUser('* Press <ENTER> to end *');
CloseUp;
END.